home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
drdobbs
/
1988
/
07
/
popups
/
popups.pas
< prev
Wrap
Pascal/Delphi Source File
|
1988-05-23
|
11KB
|
388 lines
«LM10»«AL1»«RHA
«VA$fi» «DAmm/dd/yy» «TM» Galley «PN» of «FP»
»«PT1»
UNIT popups;
(* Kent Porter, DDJ, July '88 issue *)
(* Support for pop-up windows and menu bars *)
(* Works with MDA, Compaq, CGA, EGA, VGA *)
(* Turbo Pascal 4.0 *)
INTERFACE
USES dos, crt;
(* These are names for common keystrokes *)
CONST F1 = #187; { Second byte plus 128 }
HomeKey = #199;
EndKey = #207;
PgUp = #201;
PgDn = #209;
UpCursor = #200;
DownCursor = #208;
LeftCursor = #203;
RiteCursor = #205;
Enter = #13;
(* These are structures used by the routines *)
CONST SEP = '~'; { Element separator in menu contents }
TYPE
strPtr = ^STRING;
popRec = RECORD
left, top, right, bottom, { Border locations }
style, { Border style }
normal, hilite, { Text attributes }
normback, hiback, border : INTEGER;
contents : strPtr; { Fixed text contents }
save : POINTER; { pointer to display save buffer }
oldMin, oldMax : WORD; { Previous window dimensions }
oldX, oldY : INTEGER; { previous cursor location }
oldColor : WORD; { previous fore/background colors }
END;
menuRec = RECORD
row, { row where bar appears }
interval, { cols between first chars }
fore, back : INTEGER; { fore/background colors }
choice : strPtr; { pointer to text contents }
END;
VAR VideoBuffer : POINTER; { Global pointer to text video buffer }
(* List of exported routines in this module *)
(* ---------------------------------------- *)
PROCEDURE textbox (left, top, right, bottom, style : INTEGER);
PROCEDURE popShow (VAR pop : popRec);
PROCEDURE popErase (VAR pop : popRec);
PROCEDURE popCenter (VAR pop : popRec; row : INTEGER; info : STRING);
PROCEDURE popHilite (VAR pop : popRec; row : INTEGER);
PROCEDURE popNormal (VAR pop : popRec; row : INTEGER);
PROCEDURE showMenubar (VAR spec : menuRec);
PROCEDURE cursOff;
PROCEDURE cursOn;
FUNCTION Keystroke : CHAR;
(* ---------------------------------------------------------------- *)
IMPLEMENTATION
{ Private identifiers }
CONST bufSize = 4096; { size of video buffer }
border : ARRAY [1..2, 0..5] OF CHAR = { box border chars }
(( #196, #179, #218, #191, #217, #192),
( #205, #186, #201, #187, #188, #200));
VAR egaByte : WORD ABSOLUTE $0040:$0087; { EGA eqpt byte }
reg : REGISTERS; { regs for low-level calls }
mode : WORD; { current video mode }
{ Routine bodies follow }
PROCEDURE textbox;
{ Draw textbox in indicated style, where:
0 = no border
1 = single score
2 = double score }
VAR r, c : INTEGER;
BEGIN
IF style IN [1..2] THEN BEGIN
{ Draw horizontals }
FOR c := (left+1) TO right DO BEGIN
Gotoxy (c, top); WRITE (border [style, 0]);
Gotoxy (c, bottom); WRITE (border [style, 0]);
END;
{ Draw verticals }
FOR r := (top+1) TO bottom DO BEGIN
Gotoxy (left, r); WRITE (border [style, 1]);
Gotoxy (right, r); WRITE (border [style, 1]);
END;
{ Draw corners }
Gotoxy (left, top); WRITE (border [style, 2]);
Gotoxy (right, top); WRITE (border [style, 3]);
Gotoxy (right, bottom); WRITE (border [style, 4]);
Gotoxy (left, bottom); WRITE (border [style, 5]);
END;
END; { of textbox }
(* -------------------------- *)
PROCEDURE popShow;
{ display popup described by passed structure }
PROCEDURE popWrite (VAR winText : STRING);
{ Local proc to write fixed popup contents, if any }
VAR p : INTEGER;
BEGIN
IF pop.contents <> NIL THEN BEGIN
GOTOXY (2, 1); { Always leave 1 leading space }
FOR p := 1 TO length (winText) DO
IF winText [p] <> SEP THEN
WRITE (winText [p])
ELSE
GOTOXY (2, whereY + 1); { Go to next row on separator }
END;
END; { of popWrite }
BEGIN { Body of popShow }
{ Get the current video state }
pop.oldMin := windMin + $0101;
pop.oldMax := windMax + $0101; { window dimensions }
pop.oldColor := textAttr; { current colors }
pop.oldX := whereX; pop.oldY := whereY; { cursor position }
Window (1, 1, 80, 25); { reset window to full screen }
{ Save the current screen }
GetMem (pop.save, bufSize); { allocate space for it }
Move (videoBuffer^, pop.save^, bufSize); { save screen }
{ Draw the border for the popup }
WITH pop DO BEGIN
Textcolor (border);
Textbackground (normback);
Textbox (left, top, right, bottom, style);
{ Open the window }
Textcolor (normal);
Window (left+1, top+1, right-1, bottom-1);
END; { of WITH }
{ Write fixed text }
ClrScr;
popWrite (pop.contents^);
END;
(* -------------------------- *)
PROCEDURE popErase;
{ Erase pop-up window, restoring overlaid image }
BEGIN
{ Make sure there's a saved image to restore }
IF pop.save <> NIL THEN BEGIN
window (1, 1, 80, 25);
{ Restore previous video state }
WITH pop DO BEGIN
Window (LO (oldMin), HI (oldMin),
LO (oldMax), HI (oldMax));
Textcolor (oldColor AND $0F);
TextBackground (oldColor SHR 4);
Gotoxy (pop.oldX, pop.oldY);
END;
{ Restore overlaid screen image }
Move (pop.save^, videoBuffer^, bufSize);
FreeMem (pop.save, bufSize);
pop.save := NIL;
END;
END;
(* -------------------------- *)
PROCEDURE popCenter;
{ Center string in window at specified row }
VAR col : INTEGER;
BEGIN
IF pop.save <> NIL THEN { pop-up is visible }
IF row < pop.bottom - pop.top THEN BEGIN { row is legal }
col := (pop.right - pop.left - Length (info)) DIV 2;
Gotoxy (col, row);
WRITE (info);
END;
END;
(* -------------------------- *)
PROCEDURE popRewrite (VAR pop : popRec; row : INTEGER; attrib : BYTE);
{ Local proc called by popHilite and popNormal }
{ Rewrites pop-up row with new character attribute }
VAR p, nchars : INTEGER;
BEGIN
IF pop.save <> NIL THEN { pop-up is visible }
IF row < pop.bottom - pop.top THEN BEGIN
nchars := pop.right - pop.left - 1; { Get width of row }
FOR p := 1 TO nchars DO BEGIN { For each char in row do.. }
Gotoxy (p, row); { goto char }
reg.ah := 8; { Get char }
reg.bh := 0;
intr (16, reg); { via ROM BIOS }
reg.ah := 9; { write back out with }
reg.bl := attrib; { hilite attribs }
reg.bh := 0;
reg.cx := 1;
intr (16, reg);
END;
END;
END;
(* -------------------------- *)
PROCEDURE popHilite;
{ Highlight text in specified pop-up row }
VAR attrib : BYTE;
x, y : INTEGER;
BEGIN
x := whereX; y := whereY; { Save cursor position }
Attrib := pop.hilite + (pop.hiback SHL 4); { Set text attributes }
popRewrite (pop, row, attrib); { Rewrite row }
gotoxy (x, y); { Restore cursor }
END;
(* -------------------------- *)
PROCEDURE popNormal;
{ Set text in pop-up row to normal attributes }
VAR attrib : BYTE;
x, y : INTEGER;
BEGIN
x := whereX; y := whereY;
Attrib := pop.normal + (pop.normback SHL 4);
popRewrite (pop, row, attrib);
gotoxy (x, y);
END;
PROCEDURE menuBar;
BEGIN
END;
(* -------------------------- *)
PROCEDURE showMenubar;
{ Place menu bar in current window }
VAR p, c, color, curX, curY : INTEGER;
x1, x2 : INTEGER;
BEGIN
{ Save video state information }
curX := whereX; curY := whereY;
color := TextAttr;
x1 := Lo (WindMin);
x2 := Lo (WindMax);
{ Set colors for menu }
TextColor (spec.fore);
TextBackground (spec.back);
gotoxy (1, spec.row);
WRITELN (' ');
{ Write out the bar background first }
Gotoxy (1, spec.row);
FOR p := x1 TO x2 DO
WRITE (' ');
{ Write the menubar text }
Gotoxy (1, spec.row); { First item location }
c := 1; { Item counter }
FOR p := 1 TO Length (spec.choice^) DO BEGIN { Char by char }
IF spec.choice^[p] <> SEP THEN { If not delim, }
WRITE (spec.choice^[p]) { write char }
ELSE BEGIN { else }
Gotoxy ((spec.interval * c) + 1, spec.row); { Go to next item }
INC (c); { Count items }
END
END;
{ Restore video state }
TextColor (color AND $0F);
TextBackground (color SHR 4);
Gotoxy (curX, curY);
END;
(* -------------------------- *)
PROCEDURE cursOff;
{ Turn off hardware cursor }
BEGIN
reg.ah := 3; { get current cursor shape }
reg.bh := 0; { NOTE: works in page 0 only }
Intr (16, reg);
reg.ch := reg.ch OR $20; { turn on bit 5 }
reg.ah := 1;
Intr (16, reg); { tell BIOS }
END;
(* -------------------------- *)
PROCEDURE cursOn;
{ Turn hardware cursor back on }
BEGIN
reg.ah := 3; { As above, except }
reg.bh := 0;
Intr (16, reg);
reg.ch := reg.ch AND $DF; { turn off bit 5 }
reg.ah := 1;
Intr (16, reg);
END;
(* -------------------------- *)
FUNCTION Keystroke;
{ Wait for a keystroke. If it's a special key (0+code), }
{ return the second byte + 128, else return upper case }
VAR ch : CHAR;
BEGIN
ch := UpCase (ReadKey); { Get keystroke }
IF ch = chr (0) THEN BEGIN { if a lead-in, then... }
ch := ReadKey; { get the second byte and }
ch := chr (ord (ch) + 128); { shift up by 128 }
END;
Keystroke := ch;
END;
(* ---------------------------------------------------------------- *)
{ INITIALIZATION CODE SETS ADDRESS OF VIDEO BUFFER }
Begin
Reg.ah := 15; { Get current video mode }
Intr (16, reg);
mode := reg.al;
IF (mode = 7) OR (mode = 2) THEN { Either MDA or Compaq MDA }
videoBuffer := ptr ($B000, $0000)
ELSE
videoBuffer := ptr ($B800, $0000); { else color buffer }
END. { of unit POPUPS.PAS }